perm filename SHFTX.F4[MSS,LCS] blob sn#269271 filedate 1977-03-12 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002		DIMENSION J(15)
C00004 ENDMK
CāŠ—;
	DIMENSION J(15)
4	TYPE 1
1	FORMAT(' TYPE  '$)
	ACCEPT 2,J
2	FORMAT(15A1)
	CALL NAMEXT(J,K,L)
	TYPE 3,K,L
3	FORMAT(1XA5,1X,A5)
	GO TO 4
	END

	SUBROUTINE NAMEXT(JA,NAME,IEXT)
C PUSHES 1 TO 5 A1 CHARS IN A SINGLE A5 WORD.
	DIMENSION JA(10),JB(5)
	DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
	DATA MM/"774000000000/, JB(4)/' '/,JB(5)/' '/
	JXX=0
	NAME=' '
	DO 1 K=1,4
1	IF(JA(K).EQ.' '.AND.JA(K+1).NE.' ')GO TO 2
	GO TO 12
2	PAUSE 'NO BLANKS ALLOWED!!!'
	RETURN
12	DO 20 K=1,6 
	IF(JA(K).NE.'.')GO TO 20
	JXX=-1
	J2=K+1
	JA(K)=' '
	DO 21 JX=1,4 
	JB(JX)=JA(J2)
	JA(J2)=' '
21	J2=J2+1
	GO TO 50
20	CONTINUE
50	JX=6
	DO 10 K=5,1,-1
10	IF(JA(K).EQ.' ')JX=K
	IF(JX.GT.2)GO TO 51
	N=JA(1)
	GO TO 52
51	IA=JA(1)
	IF(IA)IA=MM.AND.JA(1)
	J2=2
7	IB=JA(J2)
	IBX=IB
	IF(IBX)IB=MM.AND.JA(J2)
11	K=IB.AND.LL
4 	K=K/KK
5	IF(IBX)K=K.OR.JJ
C  RESTORES LEFT HAND BIT (101 ETC.)
	IF(J2.EQ.2)GO TO 3
	DO 8 JL=1,J2-2
8	K=K/KK
3	N=IA.OR.K
	IA=N
	J2=J2+1
	IF(J2.NE.JX)GO TO 7
52	IF(NAME.NE.' ')GO TO 23
	NAME=N
	IF(JXX.EQ.0)RETURN
	DO 24 K=1,5
24	JA(K)=JB(K)
	GO TO 50
23	IEXT=N
	END